Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/src/compiler/Globals.sml

Text File | 1997-08-18 | 6.4 KB | 272 lines | [TEXT/R*ch]

local
  open Fnlib Mixture Const Smlprim;
in

(* Internally, a global is represented by its fully qualified name,
   plus associated information. *)

type 'a global =
{
  info: 'a,               (* Description *)
  qualid: QualifiedIdent  (* Full name *)
};

datatype TyNameEqu = FALSEequ | TRUEequ | REFequ;

datatype TyStr  =
    NILts
  | TYPEts of TypeVar list * Type
  | DATATYPEts of int
  | REAts of TyName

and Type =
    VARt of TypeVar
  | ARROWt of Type * Type
  | CONt of Type list * TyName
  | RECt of { fields: (Lab * Type) list, rho: RowType } ref

and TypeVarKind =
    Explicit of string
  | NoLink
  | LinkTo of Type

and RowTypeKind =
    NILrow
  | VARrow of RowVar
  | LINKrow of RowType
  | FIELDrow of Lab * Type * RowType

and TypeScheme = TypeScheme of
{
  tscParameters: TypeVar list,
  tscBody: Type
}

withtype TyName =
{
  tnArity: int,
  tnEqu: TyNameEqu,
  tnStamp: int,
  tnStr: TyStr
} ref global

and ConInfo =
{
  conArity: int,
  conIsGreedy: bool,
  conSpan: int,
  conTag: int,
  conType : TypeScheme
} ref

and ExConInfo =
{
  exconArity: int,
  exconIsGreedy: bool,
  exconTag : (QualifiedIdent * int) option
} ref

and TypeVar =
{
  tvEqu : bool,
  tvImp : bool,
  tvKind : TypeVarKind,
  tvLevel : int,
  tvOvl : bool
} ref

and RowType = RowTypeKind ref

and RowVar =
{
  rvEqu : bool,
  rvImp : bool,
  rvLevel : int
} ref
;

type RecType = { fields: (Lab * Type) list, rho: RowType } ref;

type ConEnv = ConInfo global list;

datatype OvlType =
    REGULARo                (* Non-overloaded                *)
  | OVL1NNo                (* numtext -> num                *)
  | OVL1NSo                (* numtext -> string             *)
  | OVL2NNBo                (* numtext * numtext -> bool     *)
  | OVL2NNNo                (* num * num -> num              *)
  | OVL1TXXo                (* printVal: pseudopoly 'a -> 'a *)
  | OVL1TPUo                (* installPP: pseudopoly         *)
  | OVL2EEBo                            (* =, <>: ''a * ''a -> bool      *)
;

type PrimInfo =
{
  primArity: int,
  primOp: SMLPrim
};

datatype ConStatusDesc =
    VARname of OvlType
  | PRIMname of PrimInfo
  | CONname of ConInfo
  | EXNname of ExConInfo
  | REFname
;

type ConStatus = ConStatusDesc global;

type ConBasis = (string, ConStatus) Env;
type TyEnv  = (string, TyName) Env;
type VarEnv = (string, TypeScheme) Env;

datatype InfixStatus =
    NONFIXst
  | INFIXst of int
  | INFIXRst of int
;

type InfixBasis = (string, InfixStatus) Env;

(* Updaters *)

fun setTnStamp r new_stamp =
  let val { tnStamp=stamp, tnArity=arity, tnEqu=equ, tnStr=str } = !r in
    r := { tnStamp=new_stamp, tnArity=arity, tnEqu=equ, tnStr=str }
  end;

fun setTnEqu r new_equ =
  let val { tnStamp=stamp, tnArity=arity, tnEqu=equ, tnStr=str } = !r in
    r := { tnStamp=stamp, tnArity=arity, tnEqu=new_equ, tnStr=str }
  end;

fun setTnStr r new_str =
  let val { tnStamp=stamp, tnArity=arity, tnEqu=equ, tnStr=str } = !r in
    r := { tnStamp=stamp, tnArity=arity, tnEqu=equ, tnStr=new_str }
  end;

fun setConArity r new_arity =
  let val { conArity=arity, conIsGreedy=isGreedy,
            conTag=tag, conSpan=span, conType=typ }
          = !r
  in r :=
    { conArity=new_arity, conIsGreedy=isGreedy,
      conTag=tag, conSpan=span, conType=typ }
  end;

fun setConIsGreedy r new_isGreedy =
  let val { conArity=arity, conIsGreedy=isGreedy,
            conTag=tag, conSpan=span, conType=typ }
          = !r
  in r :=
    { conArity=arity, conIsGreedy=new_isGreedy,
      conTag=tag, conSpan=span, conType=typ }
  end;

fun setConTag r new_tag =
  let val { conArity=arity, conIsGreedy=isGreedy,
            conTag=tag, conSpan=span, conType=typ }
          = !r
  in r :=
    { conArity=arity, conIsGreedy=isGreedy,
      conTag=new_tag, conSpan=span, conType=typ }
  end;

fun setConSpan r new_span =
  let val { conArity=arity, conIsGreedy=isGreedy,
            conTag=tag, conSpan=span, conType=typ }
          = !r
  in r :=
    { conArity=arity, conIsGreedy=isGreedy,
      conTag=tag, conSpan=new_span, conType=typ }
  end;

fun setConType (r : ConInfo) new_typ =
  let val { conArity=arity, conIsGreedy=isGreedy,
            conTag=tag, conSpan=span, conType=typ }
          = !r
  in r :=
    { conArity=arity, conIsGreedy=isGreedy,
      conTag=tag, conSpan=span, conType=new_typ }
  end;

fun setExConArity r new_arity =
  let val { exconArity=arity, exconIsGreedy=isGreedy, exconTag=tag } = !r
  in r :=
    { exconArity=new_arity, exconIsGreedy=isGreedy, exconTag=tag }
  end;

fun setExConIsGreedy r new_isGreedy =
  let val { exconArity=arity, exconIsGreedy=isGreedy, exconTag=tag } = !r
  in r :=
    { exconArity=arity, exconIsGreedy=new_isGreedy, exconTag=tag }
  end;

fun setExConTag r new_tag =
  let val { exconArity=arity, exconIsGreedy=isGreedy, exconTag=tag } = !r
  in r :=
    { exconArity=arity, exconIsGreedy=isGreedy, exconTag=new_tag }
  end;

fun setTvKind r new_kind =
  let val { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
          = !r
  in r :=
    { tvKind=new_kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
  end;

fun setTvLevel r new_level =
  let val { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
          = !r
  in r :=
    { tvKind=kind, tvLevel=new_level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
  end;

fun setTvEqu r new_equ =
  let val { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
          = !r
  in r :=
    { tvKind=kind, tvLevel=level, tvEqu=new_equ, tvImp=imp, tvOvl=ovl }
  end;

fun setTvImp r new_imp =
  let val { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
          = !r
  in r :=
    { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=new_imp, tvOvl=ovl }
  end;

fun setTvOvl r new_ovl =
  let val { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=ovl }
          = !r
  in r :=
    { tvKind=kind, tvLevel=level, tvEqu=equ, tvImp=imp, tvOvl=new_ovl }
  end;

fun setRtFields r new_fields =
  let val { fields=fields, rho=rho } = !r in
    r := { fields=new_fields, rho=rho }
  end;

fun setRtRho r new_rho =
  let val { fields=fields, rho=rho } = !r in
    r := { fields=fields, rho=new_rho }
  end;

fun setRvEqu r new_equ =
  let val { rvEqu=equ, rvImp=imp, rvLevel=level } = !r in
    r := { rvEqu=new_equ, rvImp=imp, rvLevel=level }
  end;

fun setRvImp r new_imp =
  let val { rvEqu=equ, rvImp=imp, rvLevel=level } = !r in
    r := { rvEqu=equ, rvImp=new_imp, rvLevel=level }
  end;

fun setRvLevel r new_level =
  let val { rvEqu=equ, rvImp=imp, rvLevel=level } = !r in
    r := { rvEqu=equ, rvImp=imp, rvLevel=new_level }
  end;

end;